perm filename P2.F4[PAG,LCS] blob
sn#469473 filedate 1979-08-28 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C**** VARIOUS SUBROUTINES FOR PAGE LAYOUT PROGRAM. ****
C00018 ENDMK
C⊗;
C**** VARIOUS SUBROUTINES FOR PAGE LAYOUT PROGRAM. ****
SUBROUTINE FILOUT(NAMQ,NPG)
COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2
1 /SF/KL,RT,KP,STFSZ,NAMX,EXT /IVV/NUMS(1)
2 FORMAT(' TYPE FILE NAME '$)
102 FORMAT(A5)
103 TYPE 2
CALL READX(5,NAMX,EXT,NPG,NUMS)
CC103 CALL NAMEXT(EXT)
IF(NAMX.NE.' ')GO TO 1
EXT='TST'
NAMX='AAAAA'
1 NAMZ=NAMX
NPG=1
IF(LOOKX(NAMX,EXT).GE.0)GO TO 88
TYPE 88,NAMX,EXT
ACCEPT 102,L
IF(L.EQ.'N')GO TO 103
88 FORMAT(' WRITE OVER FILE ',A5,'.',A3,'???? '$)
END
SUBROUTINE FILEIN
COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2 /IPG/IPG,JPG,
1 BRACK(0/7),RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(0/7)
1 /RSP/KNM(1) /ENDL/ENDLN,N,NAME,NMPG,T /KBAR/KBAR(515)
COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
COMMON /POSI/STFF(0/7),JJ2,JPQ /LLL/L,LL,I,RXQ
COMMON/STF/RSTFAC(0/7),RSTJ2 /PX/KPN(1) /Q/Q(1)
1 /NBAR/NBAR(1)
EQUIVALENCE (LASTNM,KBAR(3))
CCC IF(NMPG.EQ.'PAGEA')NPZ='PAGEZ'
IF(NBAR(LC).EQ.0)CALL EXIT
IF(KPX.EQ.1)GO TO 104
C SKIP THIS FIRST TIME. IT SHUFFLES DATA FORWARD IN ARRAY.
J=KPX-1
JJ=KPN(KPX)-1
DO 105 K=1,NPX-J
105 KPN(K)=KPN(K+J)-JJ
J=KPN(NPX)-JJ
C HOW MUCH TO SHIFT THE Q ARRAY
CX DO 106 K=1,J
CX106 Q(K)=Q(K+JJ)
CALL RLOOP(Q,Q(JJ+1),J)
KPX =NPX-KPX+1
C UPDATE POINTERS FOR NEXT READIN
KQ=KPN(KPX)
JPX=KQ-1
104 KL=1
KP=1
JEND=0
C FLAG FOR PAGE END - WHEN -1
IF(LB.LT.NBAR(LC))GO TO 220
NPX=KPX
KPX=1
LB=0
GO TO 241
220 CALL GETEXT(NMPG,'PAG')
CALL EXTIN(RSTFAC,22)
211 CALL EXTIN(KPN(KPX),JJ2)
CALL EXTIN(Q(KQ),JPQ)
IF(KPX.EQ.1)GO TO 140
CC IF(KPX.EQ.LPX)GO TO 311
C AVOIDS DOUBLE METERS, I HOPE!
CC IF(Q(KQ+1).NE.18)GO TO 311
C LOOK AT FIRST NEW ITEM, IS IT A METER?
CC KPX=LPX
CC KQ=KPN(KPX)
C YES, GO BACK AND READ OVER OLD METERS.
CC JPX=KQ-1
CC GO TO 220
311 OLD=Q(KPN(KPX-1)+3)
B=0
JJ=JJ2+KPX-1
DO 420 JP=KPX,JJ
K=KPN(JP)+JPX
KPN(JP)=K
R=Q(K+1)
IF(B.NE.0)GO TO 420
IF(R.LE.2)GO TO 620
IF(R.NE.18)GO TO 420
CHECK UP ON METER DUPLICATE.
DO 720 KK=KPX-1,1,-1
R=CODEN(KPN,KK,Q,LA)
720 IF(R.NE.18)GO TO 820
GO TO 420
820 IF(KK.EQ.KPX-1)GO TO 420
KPX=KK+1
KQ=KPN(KPX)
JPX=KQ-1
C GO BACK AND READ OVER DANGLING METER
GO TO 220
620 B=Q(K+3)
C B=POS OF FIRST NOTE OR REST IN NEW FILE.
DO 1 KK=KPX,JP
R=CODEN(KPN,KK,Q,LA)
IF(R.NE.44)GO TO 7
IF(Q(LA+6).EQ.0.OR.Q(LA).LT.4)GO TO 1
C LOOK AT LINES, CRESC, DASHES, WIGGLES ONLY.
GO TO 2
7 IF(R.NE.7)GO TO 5
IF(Q(LA).LT.5)GO TO 1
RR=ABS(Q(LA+7))
IF(RR.GT.1.AND.RR.LT.8)GO TO 1
C AVOID PEDAL MARKS.
GO TO 2
5 IF(R.NE.5)GO TO 1
C FOUND SLUR INTO LEFT SIDE OF LINE
IF(Q(LA+3))Q(LA+3)=B-5
A=Q(LA+6)
C=Q(LA+2)
2 DO 3 NN=1,KPX-1
RR=CODEN(KPN,NN,Q,II)
IF(RR.NE.R)GO TO 3
IF(Q(II).LT.4)GO TO 3
IF(Q(II+3).GT.D)GO TO 3
IF(Q(II+2).NE.C)GO TO 3
C CATCHES ONLY ONE SLUR(ETC.) POS PER STAFF!!
IF(Q(II+6).LT.D)GO TO 3
Q(II+6)=A
C ADJUSTS PARAM 6 TO POSITION IN NEW FILE.
GO TO 1
3 CONTINUE
1 CONTINUE
420 CONTINUE
140 JPX=KQ+JPQ-3
C NUM OF WORDS TO SHIFT.
LPX=KPX
C SO IT WON'T GET CONFUSED
41 NMPG=NMPG+2
C NMPG = NAME OF INPUT FILES
IF(NMPG.EQ.'PAGEZ'+2)NMPG='PAGFA'
C WILL GO FROM PAGEA TO PAGFZ, ETC. (104) ADD TO THIS IF NEEDED.
IF(NMPG.EQ.'PAGFZ'+2)NMPG='PAGGA'
IF(NMPG.EQ.'PAGGZ'+2)NMPG='PAGHA'
CCC IF(NMPG.LE.NPZ)GO TO 2242
CCC NPZ=NPZ+256
CCC NMPG='PAGFA'
CC L=JJ2-2
CC NPX=KPX+L
2242 NPX=KPX+JJ2-2
241 JBAR=NBAR(LC)
DO 20 JP=KPX,NPX-1
R=CODEN(KPN,JP,Q,N)
CC N=KPN(JP) R=Q(N+1)
IF(R.NE.4)GO TO 20
C FINDS BAR LINES IN THIS PART OF DATA
LB=LB+1
IF(LB.NE.JBAR)GO TO 20
KPX=JP+1
D=Q(N+3)
DO 121 L=JP-1,1,-1
R=CODEN(KPN,L,Q,N)
IF(R.NE.5)GO TO 121
RR=Q(N+6)
IF(RR.LT.D)GO TO 121
Q(N+6)=-1
C=Q(N+2)
B=0
DO 221 KK=JP+1,NPX-1
R=CODEN(KPN,KK,Q,NN)
IF(R.NE.1)GO TO 221
IF(Q(NN+2).NE.C)GO TO 221
C CHECK ON STAFF NUM.
A=Q(NN+3)-1
IF(RR.LT.A)GO TO 221
B=B-1
IF(ABS(RR-A).LE.2)GO TO 321
C IF IT'S CLOSE ENOUGH CALL IT EQUAL.
221 CONTINUE
321 IF(B)Q(N+6)=B
121 CONTINUE
C SAVE POS OF LAST BAR FOR SLUR CONNECTIONS, ETC.
CC LPX=KPX
C SAVE POINTER IN CASE OF DOUBLE METERS.
20 CONTINUE
IF(LB.GE.JBAR)GO TO 520
KPX=NPX
KQ=JPX+1
GO TO 220
520 KQ=Q(KPN(KPX)+1)
IF(KQ.NE.18.AND.KQ.NE.44)GO TO 120
CC520 IF(Q(KPN(KPX)+1).NE.18)GO TO 120
C LOOKS FOR METER OR SECONDARY BAR LINES(44) BEYOND LAST BAR IN LINE.
IF(KPX.GE.NPX)GO TO 10
KPX=KPX+1
GO TO 520
120 IF(NPX.LE.KPX)GO TO 10
KK=KPX-1
R=Q(KPN(KK)+3)+.5
DO 11 K=KK,NPX
IF(Q(KPN(K)+3).GT.R)GO TO 12
11 KPX=K
C ABOVE CATCHES THINGS IN SAME POS. AS LAST BAR LINE.
12 IF(KPX.LT.NPX)KPX=KPX+1
10 KQ=KPN(KPX)
LB=LB-JBAR
L=KPX-1
C L=TOTAL ITEMS FOR THIS LINE. JBAR=TOTAL BARS, LB=HOW MANY LEFT OVER
I=L
IF(LB.NE.0)RETURN
KPX=1
KQ=1
END
SUBROUTINE STAVES
DATA SLSP/12.0/
COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2/RSIG/RSIG(0/7)
COMMON /SF/KL,RT,KP,STFSZ,NAMX /IPG/IPG,JPG,BRACK(0/7),
1 RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(0/7)
1 /RSP/KNM(1) /ENDL/ENDLN,N,NAME,NMPG,T /KBAR/KBAR(515)
COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
1 /STF/RSTFAC(0/7),RSTJ2 /IVV/OSLUR(1)
COMMON /POSI/STFF(0/7),JJ2,JPQ /LLL/L,LL,I,RXQ
1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1) /NBAR/NBAR(1)
DIMENSION ENDSTF(450),STFNM(0/7)
C ENDSTF AND ENDPTR FOR CARRYING STUFF FROM ONE LINE TO THE NEXT.
EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
1,(ENDSTF,KBAR(4))
1,(R8,RQ(6)),(R9,RQ(7)),(STFNM,KBAR(508))
IF(LC.EQ.1)RA=0
C RA IS LEFT POS OF Q DATA. (IT SHIFTS AS LC CHANGES.)
KL=1
KP=1
LC=LC+1
335 RX=0
IF(NBAR(LC).EQ.0)JEND=-1
3 JJ=KP
C ******** PUTS IN STAFF ********
RS=3.
C RS IS WDCNT FOR SUBR. STAFF
IF(RT.EQ.0)RS=6
C =6 FOR BOTTOM STAFF. PUTS IN SPACER.
CC331 IF(IPG)GO TO 411
HX=8
G=0
RX=RT
DO 611 JP=1,LPG
RT=RSTNUM(JP)
LA=RT
RS=3
C WD CNT IS RS, HX IS CODE(8), ARRAYS AND LPG(JPG) WERE SET UP IN MAIN.
RR=0
IF(NAMX.EQ.NAMZ)GO TO 11
IF(RT.NE.0)GO TO 11
RS=6
RR=SPG
C FOR SPACER ON STAFF 0
11 IF(STFNM(LA).NE.0)RS=7
611 CALL STAFF(RS,HX,G,RHGT(JP),RPSZ(JP),G,G,RR,STFNM(LA),G,G,G)
C STFNM IS INST. NAME IN P9 OF STAFF PARAMS.
HX=LPG
IF(IPG)GO TO 6
RS=4.
RT=0
CALL STAFF(2.,RS,G,HX,G,G,G,G,G,G,G,G)
DO 1611 JP=1,LPG
RT=RSTNUM(JP)
LA=RT
BR=BRACK(LA)
IF(BR.EQ.0)GO TO 1611
R7=AMOD(BR,100.)
R4=(BR-R7)/100.
CALL STAFF(5.,RS,G,R4,G,G,R7,G,G,G,G,G)
1611 CONTINUE
RT=RX
CC GO TO 511
CC411 CALL STAFF(RS,8.,0,HGT,RSTJ2,0,0,SP,SP,SP,SP,SP)
CC HGT=HGT-HX
CI511 IF(JEND)GO TO 60
C FOR PREMATURE PAGE END
CP IF(K.NE.I)GO TO 6
CI IF(RT.EQ.0)GO TO 6
CI60 IF(IPG.EQ.0)GO TO 6
CI RX=RT
CI RT=0
CI CALL STAFF(6.,8.,0,0,0,0,1.,SP,SP,SP,SP,SP)
C PUTS IN SPACER
CI RT=RX
C ****** NEXT FOR CLEFS ************
6 RX=1
IF(CLEF.EQ.-99)GO TO 33
C ONLY STAFF FOR FIRST LINE AT TOP.
RX=8.*RSTJ2
C THE SPACER
CC LA=0
CC IF(IPG)GO TO 3011
LA=LPG
3111 RT=RSTNUM(LA)
LL=RT
CLEF=RCLEF(LL)
C GETS CLEF FOR PAGE LAYOUT, RT IS STAFF# IN CALL
LA=LA-1
3011 IF(CLEF.NE.99)CALL STAFF(3.,3.,1.5,0,CLEF,0,0,0,0,0,0,0)
IF(SIG.EQ.-99)GO TO 3211
C ***** NEXT FOR KEY SIG. ********
RS=4.
R5=RSIG(LL)
332 IF(R5.NE.99)CALL STAFF(RS,17.,10.*RSTJ2,0,R5,CLEF,0,0,0,0,0,0)
3211 IF(LA.GT.0)GO TO 3111
RX=11.*RSTJ2
C RX SETS POS OF NEXT ITEM ON STAFF
R7=RX
33 LA=1
KX=0
61 IF(ENDSTF(LA).EQ.0)GO TO 31
C JUMP IF NO CARRYOVERS FROM PREVIOUS LINE.
R5=ENDSTF(LA+1)
IF(R5.NE.18)GO TO 261
CHECK UP ON METER FROM PREV. LINE. AVOID DUPLICATE.
DO 361 KK=1,I
R=CODEN(KPN,KK,Q,LL)
IF(R.EQ.4)GO TO 261
C JUMP IF METER FOUND BEFORE 1ST BAR LINE.
361 IF(R.EQ.18)GO TO 161
261 RT=ENDSTF(LA+2)
IF(R5.NE.18)GO TO 461
IF(KX)GO TO 461
KX=-1
RX=RX+4
IF(ENDSTF(LA).GT.4)RX=RX+5
461 CALL STAFF(ENDSTF(LA),ENDSTF(LA+1),ENDSTF(LA+3),ENDSTF(LA+4),
1 ENDSTF(LA+5),ENDSTF(LA+6),ENDSTF(LA+7),ENDSTF(LA+8),
1 ENDSTF(LA+9),ENDSTF(LA+10),ENDSTF(LA+11),ENDSTF(LA+12))
161 LA=LA+13
GO TO 61
C RX SPACES NEXT ITEM TO RIGHT OF LINE BEGINNING.
31 R4=Q(KPN(I)+3)
C GET POS OF LAST ITEM FOR THIS LINE
DO 32 K=1,I
32 IF(Q(KPN(K)+3).LT.R4)R4=Q(KPN(K)+3)
C ALL THIS NEEDED BECAUSE OF GRACE NOTE AT START OF LINE PROBLEM.
IF(RA.LT.R4)RA=R4
R4=RA-.1
C -.1 FOR ROUND-OFF ERRORS
LA=I
DO 831 K=1,I
KK=KPN(K)+3
C FIND SLURS ETC. BEFORE 1ST NOTES OR REST. (NOT NEG.)
IF(Q(KK).GE.RA)GO TO 231
831 Q(KK)=0
231 RA=CODEN(KPN,LA,Q,K4)
IF(RA.EQ.4)GO TO 131
IF(RA.NE.44)GO TO 931
IF(Q(K4).LE.2)GO TO 131
CATCHES BAR LINES ON UPPER STAVES.
931 LA=LA-1
GO TO 231
131 RA=Q(K4+3)
R5=RA+.001
C +.001 IS TO CATCH SLIGHT ROUNDOFF ERRORS WHEN CODE 44 IS LAST ITEM.
DO 731 K=1,I
CC KK=KPN(K) R=Q(KK+1)
R=CODEN(KPN,K,Q,KK)
IF(R.EQ.44)GO TO 631
IF(R.EQ.7)GO TO 631
IF(R.NE.5)GO TO 731
631 IF(Q(KK).LT.4)GO TO 731
R=Q(KK+6)
IF(R.LT.R5)GO TO 731
C R5 = LEFT SIDE OF ITEM NOW, R= RIGHT SIDE.
Q(KK+6)=R5
C CATCHES RIGHT SIDE OF THINGS FOR MOVER. (PEDS?)
731 CONTINUE
RS=-1
C -1 SO ALL STAVES WILL MOVE AT ONCE.
CC RS=0
R7=0
C R7=0 FOR GETPTS TO LOOK AT ALL STAVES.
R8=RX
R9=200.
LL=0
L=I
CALL PTMOVE(Q,KPN)
IF(LA.EQ.I)RETURN
C NEXT PUTS METER JUST BEYOND END OF LINE
R=202
R7=Q(KPN(LA+1)+3)
C R7 HOLDS STAFF NUM. FOR THINGS BEYOND END OF LINE.
DO 531 K5=LA+1,I
K7=KPN(K5)
K4=0
IF(Q(K7+1).EQ.18)K4=Q(K7+5)*100+Q(K7+6)
C K4 STORES METER (TOP*100+BOTTOM)
IF(Q(K7+3).EQ.R7)GO TO 531
R7=Q(K7+3)
C THIS PROBABLY WON'T ALWAYS DO THE RIGHT THING!!
R=R+5
CM IF(MTR1.GT.0.AND.K4.NE.0)MTR2=K4
531 Q(K7+3)=R
CM431 Q(K7+3)=R
CM531 IF(K4.NE.0.AND.MTR1)MTR1=K4
END
SUBROUTINE TRONLY
COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1) /PTR/JST(1)
1 /RCLF/KK,CLEF,KW,KTEM,RSTAFF,SN,YN,RNAM,IRV,ITRANS
1 /IPG/IPG,JPG,XCLEF,RSTNUM(8),RPSZ(8),RHGT(8),RRCLEF(8)
1 /ITX/ITX(18)
EQUIVALENCE (ITEM,JST(18)),(ITOT,JST(19))
1000 FORMAT(' TYPE INPUT NAME.EXT ',$)
2200 FORMAT(A5,A1,A3)
2201 FORMAT(1XA5,'.',A3)
400 FORMAT(' OUTPUT NAME.EXT ',$)
6 FORMAT(' WRITE OVER ',A5,'.',A3,'? ',$)
8 FORMAT(A1)
304 FORMAT(' TRANSP.= '$)
306 FORMAT(I)
SIG=-99
XSIG=0
300 TYPE 1000
ACCEPT 2200,NM,XIN,XIN
NX=NM+256
2001 TYPE 304
ACCEPT 2101,ITRANS
IF(ITRANS.GT.-20)GO TO 1101
2101 FORMAT(A3)
C NEXT FOR LETTER NAMES
DO 3101 K=1,18
3101 IF(ITRANS.EQ.ITX(K))GO TO 4101
5101 TYPE 240
GO TO 2001
240 FORMAT(' THIS TRANSP NOT OFFERED')
1101 REREAD 306,ITRANS
IF(ITRANS.EQ.0)GO TO 300
ITRANS=10-ITRANS
IF(ITRANS.EQ.22)ITRANS=17
C FOR DOWN OCT.
IF(ITRANS.GT.0)GO TO 700
IF(ITRANS.EQ.-2)ITRANS=18
C -2 NOW = UP OCT.
GO TO 700
4101 ITRANS=K
700 TYPE 400
ACCEPT 2200,NOUT,K,XOUT
IF(NOUT.NE.' ')GO TO 5
NOUT='AAAAA'
XOUT='TST'
C DEFAULT NAMES
5 IF(EXT.EQ.' ')EXT='TST'
IF(LOOKX(NOUT,XOUT).GE.0)GO TO 11
TYPE 6,NOUT,XOUT
ACCEPT 8,K
IF(K.EQ.'N')GO TO 700
11 JOUT=NOUT+256
10 IF(LOOKX(NM,XIN))GO TO 9
NM=NX
NX=NX+256
C WILL READ UP TO 52 FILES.
NOUT=JOUT
JOUT=JOUT+256
IF(LOOKX(NM,XIN).GE.0)CALL EXIT
9 CALL GETEXT(NM,XIN)
CALL EXTIN(JST,128)
CALL EXTIN(KPN,ITEM)
CALL EXTIN(Q,ITOT)
TYPE 2201,NM,XIN
ITEM=ITEM-2
C NEXT SORTS INTO LEFT-TO-RIGHT
CC KL=1
JPG=ITEM-1
333 DO 33 K=1,JPG
IF(CODEN(KPN,K,Q,J).GT.6)GO TO 33
A=Q(J+3)
DO 33 J=K+1,JPG
IF(CODEN(KPN,J,Q,L).GT.6)GO TO 33
IF(A.LE.Q(L+3))GO TO 33
CALL EXCH(KPN(J),KPN(K))
CC KL=J-1
GO TO 333
33 CONTINUE
C NEXT FIND HOW MANY STAVES. KSIG?
RS=0
DO 32 K=1,ITEM
R=CODEN(KPN,K,Q,J)
IF(R.GT.2)GO TO 32
IF(Q(J+2).GT.RS)RS=Q(J+2)
32 IF(R.EQ.17)SIG=0
JPG=RS+1
JITEM=ITEM
IOCT=0
KW=0
IF(ITRANS.GT.17)GO TO 98
C FOUND KSIG, SO DON'T DO THE REST
IF(XSIG.NE.0)GO TO 199
RT=0
GO TO(94,94,93,92,92, 91,91,90,90,90, 97,97,96,96,95,190,
1 102),ITRANS
C EEb,EE,F↓,F#↓,G, Ab,A,Bb,B,DMY, Db,D,Eb,E,F,G↑ BBb, 8↓, 8↑
RETURN
102 RT=8
GO TO 41
190 RT=RT-1
95 RT=RT-1
96 RT=RT-1
97 RT=RT-1
GO TO 41
98 RT=7
C OCTAVE ↑ = 19, ↓ = 18
IF(ITR.EQ.18)RT=-RT
45 IOCT=-1
GO TO 199
94 RT=RT+1
93 RT=RT+1
92 RT=RT+1
91 RT=RT+1
90 RT=RT+1
41 NSIG=-1
IF(SIG.EQ.0)GO TO 699
TYPE 42
42 FORMAT(' ADD KEY SIG? -- ',$)
RSIG=-1
ACCEPT 8,XSIG
299 IF(XSIG.NE.'Y')GO TO 199
699 NSIG=0
RSIG=0
XSIG=99
C ***** NEXT FOR KEY SIG. ********
399 IADD=0
C ADD= ADD OR SUBTR. # OR b FROM KSIG.
GO TO (73,78,75,76,81, 72,79,74,77,399,
1 71,80,73,78,75,81, 74),ITRANS
C EEb,EE,F↓,F#↓,G, Ab,A,Bb,B,DMY, Db,D,Eb,E,F,G BBb, 8↓, 8↑
71 IADD=IADD+1
72 IADD=IADD+1
73 IADD=IADD+1
74 IADD=IADD+1
75 IADD=IADD+1
C 75=F, 81=G, 79=A, 73=E FLAT, 74=Bb, 80=D
GO TO 199
76 IADD=IADD-1
77 IADD=IADD-1
78 IADD=IADD-1
79 IADD=IADD-1
80 IADD=IADD-1
81 IADD=IADD-1
199 K=1
XCLEF=0
CLEF=-1
CC RSIG=0
SLUR=0
PRX=99
MS=1
SN=KW
599 X=CODEN(KPN,K,Q,J)
IF(X.NE.4)GO TO 2
BAR=-1
MS=1
GO TO 100
2 IF(Q(J+2).NE.SN)GO TO 100
CHECK FOR STAFF NUM.
IF(X.EQ.1)GO TO 1
20 IF(X.NE.17)GO TO 12
RSIG=-1
R=Q(J+5)
C KSIG NUM.
A=R+IADD
CHANGED TO A
IF(ABS(A).LT.8)GO TO 123
C AVOIDS IMPOSSIBLE KSIG, DOES ENHARMONIC CHANGE.
IF(A)GO TO 223
ITRANS=9
A=A-12
RT=RT+1
GO TO 123
223 A=A+12
ITRANS=11
RT=RT-1
123 IF(A.NE.0)GO TO 23
M=Q(J)+3
C THIS WILL DELETE KSIG
ITOT=ITOT-M
KL=ITOT-J
CALL RLOOP(Q(J),Q(J+M),KL)
DO 334 J=K,JITEM
334 KPN(J)=KPN(J+1)-M
JITEM=JITEM-1
K=K-1
GO TO 100
23 Q(J+5)=A
NSIG=0
12 IF(X.EQ.5)GO TO 120
IF(X.NE.3)GO TO 26
IF(Q(J+5).GT.3)GO TO 100
C SKIP NON-CLEFS
IF(CLEF.GE.0)GO TO 100
C FINDS ONLY 1 CLEF PER STAFF
XCLEF=Q(J+5)
IF(Q(J).LT.3)XCLEF=0
CLEF=0
GO TO 100
26 IF(X.NE.6)GO TO 100
120 IF(RT.NE.8)GO TO 121
IF(XCLEF.EQ.1)RT=-4
C WHAT ABOUT C CLEFS??
121 Q(J+4)=Q(J+4)+RT
Q(J+5)=Q(J+5)+RT
IF(X.EQ.5)SLUR=Q(J+6)
C SAVES RIGHT POS. OF SLUR
GO TO 100
C FOR BEAMS AND SLURS
1 R=Q(J+4)
XRT=RT
IF(Q(J).LT.6)GO TO 111
C SKIP IF NO STEM INFO
RX=Q(J+8)
IF(RX.GT.999.0)GO TO 111
IF(RX.EQ.999.0)RX=0
RX=RX+RT
IF(RX)RX=0
C RESET STEM LENGTH. NEVER SHORTER THAN 0 (NORMAL).
Q(J+8)=RX
111 IF(IOCT)GO TO 4
C IOCT=-1 FOR OCT+ OR OCT-
RX=AMOD(R,100.0)
RZ=AMOD(RX,7.0)
C THE NOTE NUM
IF(RZ)RZ=RZ+7
C PUTS IT IN 0-6 RANGE FOR ACCI CHANGE SECTION.
R5=Q(J+5)
A=AMOD(R5,10.0)
C THE ACCI
RN(MS)=A
RN(MS+1)=RX
C SAVE FOR REPEATS
MS=MS+2
CHNAT=3
IF(MS.LT.4)GO TO 205
N=MS-3
200 IF(RX.NE.RN(N))GO TO 201
IF(A.EQ.0)GO TO 4
C NOW WE'VE FOUND THE SAME NOTE WITH NO ACCI IN SAME MEAS.
GO TO 203
201 N=N-2
IF(N.GE.1)GO TO 200
205 IF(NSIG)CHNAT=0
203 ADD=A
C THE CHANGE IN ACCI
IF(PRX.NE.RX)GO TO 44
C IF PREV ACCI AND NT ARE SAME, SKIP OVER.
IF(A.NE.0)GO TO 44
C NOW SAME NOTE, NO ACCI
IF(ABS(SLUR-Q(J+3)).GT.3)GO TO 44
C FOUND CONNECTING TIE
C OR SET MS BACK TO 200 WHEN TIE IS PRESENT. THIS WILL
CAUSE LATER SAME NOTE TO HAVE ACCI (I HOPE.)
IF(BAR)MS=1
IF(A.NE.0)GO TO 203
GO TO 4
44 IF(NSIG)GO TO 440
CCC IF(ITRANS.GE.17)GO TO 69
IF(A.EQ.0)GO TO 4
C ONLY CHECKS ON NOTES WITH NO ACCI
IF(ITRANS.GE.18)GO TO 4
440 IF(XCLEF.NE.1)GO TO 69
RZ=RZ-5
IF(RZ)RZ=RZ+7
69 GO TO (63,52,53,54,55, 56,57,58,59,440, 61,62,63,52,53,55
1 ,64),ITRANS
C EEb,EE,F↓,F#↓,G, Ab,A,Bb,B,DMY, Db,D,Eb,E,F BBb
54 IF(RZ.EQ.3)GO TO 101
59 IF(RZ.EQ.6)GO TO 101
52 IF(RZ.EQ.2)GO TO 101
57 IF(RZ.EQ.5)GO TO 101
C FOR "A". FINDS C,F AND G.
62 IF(RZ.EQ.1)GO TO 101
55 IF(RZ.EQ.4)GO TO 101
C "G" F→Bb, F#→B NAT.
GO TO 4
61 IF(RZ.EQ.5)GO TO 7
56 IF(RZ.EQ.2)GO TO 7
63 IF(RZ.EQ.6)GO TO 7
58 IF(RZ.EQ.3)GO TO 7
53 IF(RZ.NE.0)GO TO 4
7 IF(A.EQ.0)GO TO 402
IF(A.EQ.3)GO TO 402
C CHNG NO ACCI OR NAT TO SHARP
IF(A.EQ.4)GO TO 401
C 4=bb 5=##
IF(A.EQ.2)GO TO 405
30 ADD=CHNAT
C MAKE IT NAT. IF NEEDED
3 Q(J+5)=R5-A+ADD
4 PRX=RX
C REAL NOTE LEVEL
Q(J+4)=R+XRT
BAR=0
100 IF(K.GE.JITEM)GO TO 499
K=K+1
GO TO 599
C NEXT FOR BSCLAR.---ADD OTHERS HERE!!!
64 IF(XCLEF.EQ.1)XRT=XRT-12
GO TO 58
101 IF(A.EQ.0)GO TO 401
IF(A.EQ.2)GO TO 30
IF(A.EQ.3)GO TO 401
IF(A.EQ.5)GO TO 402
C WON'T HANDLE Gbb→Ab
404 ADD=4
GO TO 3
401 ADD=1
GO TO 3
402 ADD=2
GO TO 3
405 ADD=5
GO TO 3
499 KW=KW+1
IF(RSIG)GO TO 498
IF(IADD.EQ.0)GO TO 498
M=ITOT
C INSERT NEW KSIG
Q(M)=4
Q(M+1)=17
Q(M+2)=SN
Q(M+3)=9
Q(M+4)=0
Q(M+5)=IADD
Q(M+6)=XCLEF
ITOT=ITOT+7
JITEM=JITEM+1
KPN(JITEM+1)=ITOT
498 IF(KW.LT.JPG)GO TO 199
CALL RVRS(JITEM)
C TO REVERSE STEMS, BEAMS AND SLURS
497 DO 496 K=1,ITEM-1
C THIS REORDERS PTR ARRAY
IF(KPN(K).LT.KPN(K+1))GO TO 496
CALL EXCH(KPN(K),KPN(K+1))
GO TO 497
496 CONTINUE
CALL PUTEXT(NOUT,XOUT)
ITEM=JITEM+2
CALL EXTOUT(JST,128)
CALL EXTOUT(KPN,ITEM)
CALL EXTOUT(Q,ITOT)
CALL FINEXT
TYPE 2201,NOUT,XOUT
NOUT=NOUT+2
NM=NM+2
GO TO 10
END
C**** TRNSP, RVRS, BMGHT, CUES ***************
SUBROUTINE TRNSP
COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1)
COMMON/STF/RSTFAC(0/7),RSTJ2 /IPG/IPG,JPG,BRACK(8),
1 RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(0/7)
1 /RCLF/KK,CLEF,KW,ITEM,RSTAFF,SN,YN,RNAM,IRV,ITR
COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
1,LC,LPG,MPG,ZCLEF,SIG,LB,SPG,MTR1,MTR2
1 /LLL/LEND,NO1,NO2,NO3,XSIG /RSIG/RSIG(0/7)
IOCT=0
RXT=99.
KW=0
IF(ITR.GT.17)GO TO 98
1002 IF(SIG.NE.-99)GO TO 199
C FOUND KSIG, SO DON'T DO THE REST
IF(XSIG.NE.0)GO TO 2002
RT=0
GO TO(94,94,93,92,92, 91,91,90,90,90, 97,97,96,96,95,190,
1 102),ITR
C EEb,EE,F↓,F#↓,G, Ab,A,Bb,B,DMY, Db,D,Eb,E,F,G↑ BBb, 8↓, 8↑
RETURN
102 RT=8
GO TO 41
190 RT=RT-1
95 RT=RT-1
96 RT=RT-1
97 RT=RT-1
GO TO 41
98 RT=7
C OCTAVE ↑ = 19, ↓ = 18
IF(ITR.EQ.18)RT=-RT
45 IOCT=-1
GO TO 199
94 RT=RT+1
93 RT=RT+1
92 RT=RT+1
91 RT=RT+1
90 RT=RT+1
41 NSIG=-1
IF(RSIG(KW).NE.99)GO TO 699
C ASSUMES KSIG DESIRED IF ONE THERE ALREADY.
TYPE 42
42 FORMAT(' ADD KEY SIG? -- ',$)
43 FORMAT(A1)
ACCEPT 43,XSIG
299 IF(XSIG.NE.'Y')GO TO 199
699 NSIG=0
XSIG=99
C ***** NEXT FOR KEY SIG. ********
399 IADD=0
C ADD= ADD OR SUBTR. # OR b FROM KSIG.
GO TO (73,78,75,76,81, 72,79,74,77,399,
1 71,80,73,78,75,81, 74),ITR
C EEb,EE,F↓,F#↓,G, Ab,A,Bb,B,DMY, Db,D,Eb,E,F,G↑ BBb, 8↓, 8↑
71 IADD=IADD+1
72 IADD=IADD+1
73 IADD=IADD+1
74 IADD=IADD+1
75 IADD=IADD+1
C 75=F, 81=G, 79=A, 73=E FLAT, 74=Bb, 80=D
GO TO 2002
76 IADD=IADD-1
77 IADD=IADD-1
78 IADD=IADD-1
79 IADD=IADD-1
80 IADD=IADD-1
81 IADD=IADD-1
2002 K=0
2003 R=0
RZ=RSIG(K)
IF(RZ.NE.99)R=RZ
R=IADD+R
IF(R.EQ.0)GO TO 799
IF(ABS(R).LT.8)GO TO 899
C IF IMPOSSIBLE KSIG, DO ENHARMONIC SHIFT
IF(R)GO TO 1899
R=R-12
ITR=9
RT=RT+1
GO TO 899
1899 R=R+12
ITR=11
RT=RT-1
899 IF(IPG.GT.0)GO TO 799
C SKIP IF TRNSP ONLY.
IF(RZ.NE.99)GO TO 799
SIG=0
CALL STAFF(4.,17.,4.0*RSTJ2,0,R,CLEF,0,0,0,0,0,0)
799 RSIG(K)=R
K=K+1
IF(K.LT.JPG)GO TO 2003
199 K=1
CC CLEF=RCLEF(KW)
SLUR=0
PRX=99
MS=200
SN=KW
599 X=CODEN(KPN,K,Q,J)
IF(X.EQ.4)GO TO 2
IF(Q(J+2).NE.SN)GO TO 100
CHECK FOR STAFF NUM.
IF(X.EQ.1)GO TO 1
IF(X.NE.3)GO TO 20
CC IF(IPG.GT.0)GO TO 100
CLEF=Q(J+5)
IF(Q(J).LT.3)CLEF=0
IF(ITR.EQ.16.OR.ITR.EQ.3)GO TO 21
C NEXT FOR HORN IN F CLEF CHANGES
GO TO 100
C NEXT FOR BASS CL. CLEF CHANGES.
21 IF(CLEF.NE.0)Q(J+5)=0
IF(Q(J+4).LT.100)GO TO 100
CALL SHRNK(K,LEND)
C MAKE IT INVISIBLE IF IT WAS MINI.
GO TO 599
2 BAR=-1
MS=200
GO TO 100
20 IF(X.NE.17)GO TO 12
C HOW ABOUT CHANGE TO NO SIG? OK, CODE =99
R=Q(J+5)
C KSIG NUM.
A=R+IADD
CHANGED TO A
IF(A.GE.8)A=A-12
IF(A.LE.-8)A=A+12
IF(A.NE.0)GO TO 23
A=100
CHANGE KSIG TO NATURALS
IF(R)A=-A
A=R+A
RSIG(KW)=A
CC RSIG(KW)=99
23 Q(J+5)=A
NSIG=0
12 IF(X.NE.5)GO TO 123
SLUR=Q(J+6)
GO TO 121
C SAVES RIGHT POS. OF SLUR
123 IF(X.NE.6)GO TO 100
121 A=RT
C FOR BEAMS AND SLURS
IF(A.EQ.8)GO TO 122
IF(A.NE.4)GO TO 124
C A=8=BS.CL. =4=HRN????????????????????NO MORE CLEF CHNG FOR HRN.
122 IF(CLEF.EQ.1)A=A-12
C BASS CLEF → TREBLE
124 Q(J+4)=Q(J+4)+A
Q(J+5)=Q(J+5)+A
C ASSUMES NO CLEF CHANGE BETWEEN END POINTS OF SLUR OR BEAM.
GO TO 100
1 IF(Q(J).GE.7.AND.Q(J+9))GO TO 100
C IF P9 IS NEG. IT'S A NOTE WITHOUT LEDGER LINES. IGNORE IT.
R=Q(J+4)
XRT=RT
IF(Q(J).LT.6)GO TO 111
C SKIP IF NO STEM INFO
RX=Q(J+8)
IF(RX.GT.999.0)GO TO 111
IF(RX.EQ.999.0)RX=0
RX=RX+RT
IF(RX)RX=0
C RESET STEM LENGTH. NEVER SHORTER THAN 0 (NORMAL).
Q(J+8)=RX
111 IF(IOCT)GO TO 4
C IOCT=-1 FOR OCT+ OR OCT-
RX=AMOD(R,100.0)
RZ=AMOD(RX,7.0)
C THE NOTE NUM
IF(RZ)RZ=RZ+7
C PUTS IT IN 0-6 RANGE FOR ACCI CHANGE SECTION.
R5=Q(J+5)
A=AMOD(R5,10.0)
C THE ACCI
RN(MS)=A
RN(MS+1)=RX
C SAVE FOR REPEATS
MS=MS+2
CHNAT=3
IF(MS.LT.203)GO TO 205
N=MS-3
200 IF(RX.NE.RN(N))GO TO 201
IF(A.EQ.0)GO TO 444
C NOW WE'VE FOUND THE SAME NOTE WITH NO ACCI IN SAME MEAS.
GO TO 203
201 N=N-2
IF(N.GE.200)GO TO 200
205 IF(NSIG)CHNAT=0
203 ADD=A
C THE CHANGE IN ACCI
IF(PRX.NE.RX)GO TO 44
C IF PREV ACCI AND NT ARE SAME, SKIP OVER.
IF(A.NE.0)GO TO 44
C NOW SAME NOTE, NO ACCI
IF(ABS(SLUR-Q(J+3)).GT.3)GO TO 44
C FOUND CONNECTING TIE
C THIS ↑↑↑↑ ALWAYS PUTS ACCI AFTER A BAR -- EVEN WITH TIE------
C OR SET MS BACK TO 200 WHEN TIE IS PRESENT. THIS WILL
CAUSE LATER SAME NOTE TO HAVE ACCI (I HOPE.)
IF(BAR)MS=200
IF(A.NE.0)GO TO 203
GO TO 444
44 IF(NSIG)GO TO 440
CCC IF(ITR.GE.17)GO TO 69
IF(A.EQ.0)GO TO 444
C ONLY CHECKS ON NOTES WITH NO ACCI
IF(ITR.GE.18)GO TO 444
440 IF(CLEF.NE.1)GO TO 69
RZ=RZ-5
IF(RZ)RZ=RZ+7
69 GO TO (63,52,64,54,55, 56,57,58,59,440, 61,62,63,52,53,55
1 ,64),ITR
C EEb,EE,F↓,F#↓,G, Ab,A,Bb,B,DMY, Db,D,Eb,E,F,G↑ BBb
54 IF(RZ.EQ.3)GO TO 101
59 IF(RZ.EQ.6)GO TO 101
52 IF(RZ.EQ.2)GO TO 101
57 IF(RZ.EQ.5)GO TO 101
C FOR "A". FINDS C,F AND G.
62 IF(RZ.EQ.1)GO TO 101
55 IF(RZ.EQ.4)GO TO 101
C "G" F→Bb, F#→B NAT.
GO TO 4
61 IF(RZ.EQ.5)GO TO 7
56 IF(RZ.EQ.2)GO TO 7
63 IF(RZ.EQ.6)GO TO 7
58 IF(RZ.EQ.3)GO TO 7
53 IF(RZ.NE.0)GO TO 4
7 IF(A.EQ.0)GO TO 402
IF(A.EQ.3)GO TO 402
C CHNG NO ACCI OR NAT TO SHARP
IF(A.EQ.4)GO TO 401
C 4=bb 5=##
IF(A.EQ.2)GO TO 405
30 ADD=CHNAT
C MAKE IT NAT. IF NEEDED
3 Q(J+5)=R5-A+ADD
4 PRX=RX
C REAL NOTE LEVEL
Q(J+4)=R+XRT
BAR=0
RXT=XRT
100 IF(K.GE.LEND)GO TO 499
K=K+1
GO TO 599
C NEXT FOR BSCLAR.---ADD OTHERS HERE!!!
64 IF(CLEF.EQ.1)XRT=XRT-12
IF(ITR.EQ.3)GO TO 53
GO TO 58
444 IF(RXT.NE.99.)XRT=RXT
C THIS FOR BS.CL. AND HRN. REPEATED NOTES.
GO TO 4
101 IF(A.EQ.0)GO TO 401
IF(A.EQ.2)GO TO 30
IF(A.EQ.3)GO TO 401
IF(A.EQ.5)GO TO 402
C WON'T HANDLE Gbb→Ab
404 ADD=4
GO TO 3
401 ADD=1
GO TO 3
402 ADD=2
GO TO 3
405 ADD=5
GO TO 3
499 KW=KW+1
IF(KW.LT.JPG)GO TO 199
CALL RVRS(LEND)
C TO REVERSE STEMS, BEAMS AND SLURS
END
SUBROUTINE RVRS(LEND)
COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1)
1 /RCLF/KK,CLEF,KW,ITEM,RSTAFF,SN,YN,RNAM,IRV,ITR
1 /IPG/IPG,JPG,BRA(8),RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(8)
DATA RSTEM/6.5/
KW=0
CZZ IRV=0
CZZ IF(ITR.LT.10)GO TO 100
CZZ IF(ITR.NE.18)IRV=-1
C TRNS ↓ + STEM ↑ = NO CHNG, TRNS ↑ +STEM ↓ = NO CHNG
100 K=1
SN=KW
DO 30 N=1,LEND
IF(CODEN(KPN,N,Q,J).NE.1)GO TO 30
C LOOK FOR NOTES WITH STEM BUT NO RHYTH. VALUE
IF(Q(J+2).NE.SN)GO TO 30
C ON THIS STAFF?
IF(Q(J).LT.7)GO TO 31
IF(Q(J+9).NE.0)GO TO 30
31 IF(Q(J+5).GE.10)GO TO 102
C FOUND A 0 RHYTHM WITH A STEM - IGNORE THIS STAFF
30 CONTINUE
1 R=CODEN(KPN,K,Q,J)
IF(Q(J+2).NE.SN)GO TO 10
CHECK ON STAFF NUM.
IF(R.NE.1)GO TO 2
C JUMP IF NOT A NOTE
CZZ IF(NORVRS(Q(J+5)))GO TO 10
CHECKS STEM DIR. AND TRNS DIR.
IF(Q(J+5).LT.10)GO TO 10
C JUMP IF NO STEM ON IT
IF(Q(J).GT.6.AND.Q(J+9))GO TO 10
C SKIP NOTES WITH NO LEDGER LINES
KK=K+1
3 IF(KK.GT.LEND)GO TO 102
RR=CODEN(KPN,KK,Q,JJ)
IF(Q(JJ+2).EQ.SN)GO TO 101
GO TO 7
101 IF(RR.NE.1)GO TO 5
C JUMP IF NOT A NOTE
IF(Q(JJ+5).GE.10)GO TO 6
C SKIP CHORD NOTES (NO STEM)
7 KK=KK+1
GO TO 3
C DID NOT FIND BEAM NEARBY
6 RZ=AMOD(Q(J+4),100.0)
N=J+5
A=10
IF(RZ.GE.7)GO TO 60
IF(Q(N).LT.20)GO TO 10
C NOW STEM SHOULD BE DOWN IF WITHOUT BEAM OR 1ST NT UNDER BEAM.
A=-A
GO TO 15
60 IF(Q(N).GE.20)GO TO 10
C THERE MUST BE A BETTER WAY!
15 Q(N)=Q(N)+A
GO TO 10
CCC5 IF(RR.NE.6)GO TO 6
5 IF(RR.EQ.6)GO TO 20
IF(Q(JJ+3).NE.Q(J+3))GO TO 6
CATCHES OTHER THINGS AT EXACTLY SAME POS. AS NOTE AND BEAM.
KK=KK+1
GO TO 3
20 B=Q(JJ+4)
C=Q(JJ+5)
D=(B+C)/2.
IF(RR.EQ.5)GO TO 9
IF(RR.NE.6)GO TO 10
CALL BMHGT(B,C,JJ)
120 B=Q(JJ+6)+.5
C SAVES RANGE OF BEAM +1.
IF(Q(JJ+7).GE.20)GO TO 11
C NOW STEMS ARE UP
IF(D.LT.RSTEM)GO TO 12
C JUMP TO 12 IF ALL OK
JSTM=0
C SAVE FOR REVERSED STEMS
GO TO 23
11 IF(D.GE.RSTEM)GO TO 12
C STEMS DOWN
C JUMP IF NO REVERSE NEEDED
JSTM=-1
23 JH=0
CHNG=0
N=K
164 R=CODEN(KPN,N,Q,KK)
IF(Q(KK+2).NE.SN)GO TO 16
IF(Q(KK+3).GT.B)GO TO 140
IF(R.NE.1)GO TO 17
L=5+KK
IF(Q(L).LT.10)GO TO 16
C PASS NOTES WITH NO STEM
R=Q(KK+8)
C THE STEM LENGTH
IF(R.EQ.999)R=0
Q(KK+8)=-R
C FOR THE INVERSION
19 BC=10.
A=Q(L)
IF(A.GE.20)BC=-BC
Q(L)=BC+A
IF(JH.NE.0)GO TO 161
C NEXT FOR 1ST NOTE UNDER BEAM
JH=4
160 R=Q(JJ+JH)-Q(KK+4)
A=-1
IF(JSTM)GO TO 163
A=R
R=1
C NOW STEMS UP
163 IF(R.GT.A)GO TO 162
C JUMP IF BEAM IS NOT TOO CLOSE TO NOTE
CHNG=A-R
IF(JSTM.EQ.0)CHNG=-CHNG
162 IF(L)GO TO 141
C FOR ESCAPE FROM LOOP
161 JH=KK
C JH SAVES PTR TO LAST NOTE UNDER BEAM
GO TO 16
17 IF(R.NE.6)GO TO 18
C NOW IT'S A BEAM
L=7+KK
CALL BMHGT(Q(KK+4),Q(KK+5),KK)
GO TO 19
18 IF(R.NE.5)GO TO 16
C NOW IT'S A SLUR
C=-4
IF(Q(KK+8).LT.-1)C=-1.8
IF(Q(KK+7))C=-C
CALL SLRV(KK,C)
C TO REVERSE SLUR
16 N=N+1
IF(N.LE.LEND)GO TO 164
C SHOULD ALWAYS EXIT FROM LOOP BEFORE END OF ARRAY!
140 KK=JH
L=-1
JH=5
C GO BACK TO CHECK HGT OF LAST NOTE AND RIGHT END OF BEAM
GO TO 160
141 IF(CHNG.EQ.0)GO TO 14
C=CHNG
IF(CHNG)CHNG=-CHNG
DO 142 N=K,LEND
C TO READJUST STEMS UNDER REVERSED BEAMS
R=CODEN(KPN,N,Q,KK)
IF(Q(KK+2).NE.SN)GO TO 142
IF(Q(KK+3).GT.B)GO TO 14
CC IF(R.NE.1)GO TO 242
CC Q(KK+8)=Q(KK+8)+CHNG
C THE STEM LENGTH
CC GO TO 142
242 IF(R.NE.6)GO TO 142
Q(KK+4)=Q(KK+4)+C
Q(KK+5)=Q(KK+5)+C
142 CONTINUE
GO TO 14
C NEXT FOR SLURS
9 B=-4
IF(Q(JJ+8).LT.-1)B=-1.8
IF(Q(JJ+7))GO TO 24
IF(D.GT.RSTEM)GO TO 10
C JUMP TO LEAVE STEM UP
GO TO 25
24 IF(D.LT.5)GO TO 10
C JUMP TO LEAVE STEM DOWN
B=-B
25 CALL SLRV(JJ,B)
GO TO 10
12 DO 13 N=K+1,LEND
KK=KPN(N)
IF(Q(KK+2).NE.SN)GO TO 13
C IS THIS NEEDED↑↑↑↑??
IF(Q(KK+3).GT.B)GO TO 14
IF(Q(KK+1).EQ.6.)CALL BMHGT(Q(KK+4),Q(KK+5),KK)
13 CONTINUE
C JUMP OUT WHEN PAST END OF BEAM.
14 IF(N.GT.K)K=N-1
C ↑↑↑↑↑↑ WHY????????????
GO TO 10
2 IF(R.NE.6)GO TO 21
CZZ IF(NORVRS(Q(J+7)))GO TO 10
22 JJ=J
RR=R
GO TO 20
CZZ21 IF(R.NE.5)GO TO 10
CZZ RR=20
CZZ IF(Q(J+7))RR=10
CZZ IF(NORVRS(RR).GE.0)GO TO 22
21 IF(R.EQ.5)GO TO 22
10 IF(R.NE.1)GO TO 202
C NEXT FIXES STEM LENGTHS
B=0
A=AMOD(Q(J+4),100.0)
IF(A.GE.80)A=A-100.
C A=HEIGHT OF NOTE
IF(Q(J+5).GE.20.)GO TO 302
C JUMP IF STEMS ARE DOWN
IF(A.LT.0)B=-A
C LENGTHEN STEM IF NOTE IS TOO FAR BELOW STAFF
GO TO 402
302 IF(A.GT.14)B=A-14.
402 Q(J+8)=B
202 IF(K.GT.LEND)GO TO 102
K=K+1
GO TO 1
102 KW=KW+1
IF(KW.LT.JPG)GO TO 100
END
CZZ FUNCTION NORVRS(R)
CZZ COMMON /RCLF/KK,CLEF,KW,ITEM,RSTAFF,SN,YN,RNAM,IRV,ITR
CZZ NORVRS=0
CZZ IF(R.LT.20)GO TO 1
C NOW STEM UP
CZZ IF(IRV)RETURN
CZZ2 NORVRS=-1
CZZ RETURN
CZZ1 IF(IRV)GO TO 2
CZZ END
SUBROUTINE BMHGT(B,C,JJ)
COMMON /Q/Q(1)
BB=0
IF(ABS(B).LT.80)GO TO 1
C JUMP IF NOT MINI-BEAM
BB=B-100.
IF(B.LT.0)BB=B+100.
B=BB
1 BC=ABS(Q(JJ+7))
IF(BC.GE.20.)GO TO 121
IF(B.GE.0.AND.C.GE.0)RETURN
C NEXT TO CHANGE HGT. OF BEAMS TOO HIGH OR TOO LOW.
BC=-C
IF(B.LT.C)BC=-B
C -B IF C IS LOWEST
122 IF(BB.NE.0)B=B+100.
Q(JJ+4)=B+BC
Q(JJ+5)=C+BC
C BOTH SIDES ARE NOW SHIFTED
RETURN
121 IF(B.LE.14.AND.C.LE.14)RETURN
C NOW AT LEAST ONE SIDE IS TOO HIGH
BC=14-C
IF(B.GT.C)BC=14-B
GO TO 122
END
SUBROUTINE CUES
COMMON /PX/KPN(1)/XRN/RN(1)/PTR/KWDS(1)/RCLF/KK,CLEF,KW,ITEM
1 /LLL/LLL /Q/Q(1)
DO 1 K=LLL,1,-1
C BACK THROUGH ARRAY FROM LAST CUE FOUND.
IF(CODEN(KPN,K,Q,J).NE.2)GO TO 1
C NEXT FOUND A REST
IF(Q(J).LT.8)GO TO 1
C JUMP IF WDCNT IS TOO SMALL
IF(Q(J+10).LT.100)GO TO 1
C P10=100+STAFF NUM. OF CUE DATA. JUMP IF IMPROPER NUM.
STF=Q(J+10)-100.
POS=Q(J+3)
C POSITION OF THIS REST
PLEFT=0
PRGHT=1000
C POSITIONS FOR BARS TO LEFT AND RIGHT. NEXT FIND PROPER BARS.
DO 2 L=1,ITEM
IF(CODEN(KWDS,L,RN,N).NE.4)GO TO 2
C FIND A BAR AND ITS POS.
X=RN(N+3)
IF(X.GT.POS)GO TO 3
C IS TO LEFT OR RIGHT OF REST?
IF(X.GT.PLEFT)PLEFT=X
GO TO 2
3 IF(X.LT.PRGHT)PRGHT=X
2 CONTINUE
C NOW FOUND BARS ON EACH SIDE OF REST.
DO 4 L=1,ITEM
C NOW FIND NOTES WITHIN PROPER BAR AND ON PROPER STAFF
R=CODEN(KWDS,L,RN,N)
IF(RN(N+2).NE.STF)GO TO 4
RS=RN(N+3)
C POS. OF ITEM.
IF(RS.GT.PRGHT)GO TO 4
IF(RS.LT.PLEFT)GO TO 4
C NOW BETWEEN BARS.
IF(R.GT.6)GO TO 4
C USE NOTES,RESTS,CLEFS,SLURS,BEAMS
IF(R.NE.5)RN(N+4)=RN(N+4)+100.
C MAKE ALL MINIS AND PUT ON STAFF 0
RN(N+2)=0
IF(R.GT.2)GO TO 5
JJ=N+11-R*2.0
RN(JJ)=RN(JJ)/2.
C JJ=9 OR 7. CUT RHYTH VALS OF CUES 1/2 - SO THEY WILL OCCUPY LESS SPACE.
5 CALL QRN(N,KPN,L)
C GO PUT IT INTO Q ARRAY
4 CONTINUE
CC Q(J+3)=POS+1
C SHIFT THE WHOLE REST A BIT TO THE RIGHT.
Q(J+10)=0
Q(J+4)=5.
C PUT IT ABOVE STAFF.
Q(J+5)=-2
C P5=-2=WHOLE REST
Q(J+9)=0
CC Q(J+8)=-1.
Q(J+7)=-1.
C NEG. RHYTHM MAKES REST IGNORED BY ALL JUSTIFYING ROUTINES.
1 CONTINUE
END
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C****** PTMOVE.F4 ALSO SUBR. TURN (FOR PAGE-TURN FINDING)
C00006 ENDMK
C⊗;
C****** PTMOVE.F4 ALSO SUBR. TURN (FOR PAGE-TURN FINDING)
SUBROUTINE PTMOVE(RN,PWDS)
IMPLICIT INTEGER(A-Q,S-Z)
REAL POS,EXTEN,PRCNT,ACCX,SPFAC
DIMENSION R(2,400),IR(2,400),RN(1),PWDS(1)
COMMON/KNR/KR(400) /NNP/NP(400) /JSTFY/ROV,PRCNT,RJSZ
COMMON/STF/RSTFAC(0/7),RSTJ2 /KJY/ KY,JY
COMMON R2,JA,CENTR,J2,RJQ(18),RNO,JR,LX,RDIS
COMMON/POSI/STFF(0/7),JJ2,POS/LLL/ITEM,LL,I,IX
1 /IPG/IPG,JPG,BRACK,RSTNUM(8),RPSZ(8),RHGT(8),
1 RCLEF(0/7)
EQUIVALENCE (R5,RJQ(3)),(R4,RJQ(2))
1,(R3,RJQ(1)),(R8,RJQ(6)),(R9,RJQ(7))
1,(IR,R)
DATA RSP/2.7/,RI/4.7/,SPFAC/2.7/
C RI IS SIZE FACTOR FOR SPACING. IF LARGER THEN REQUIRES MORE SPACE.
JJ2=-1
J2=0
C 99=BACKUP
IF(LL.EQ.'J')GO TO 12
RDIS=0
CCC66 NST=1
JJ=0
IF(R4.NE.R8.OR.R5.NE.R9)JJ=-1
JY=0
C JY IS CHANGED IN GETPTS
IF(JJ)CALL GETPTS(LX,RN,PWDS)
IF(JY.EQ.0)RETURN
CALL MOVIT(RN,KR,R4,R5,R8,R9)
RETURN
12 IF(R4.EQ.0)R4=.001
CCC IF(R5.EQ.0)R5=200
RCNT=0
RRT=R5
RZRO=R4
RJSZ=RI
CALL GETPTS(LX,RN,PWDS)
IF(JY.EQ.0)RETURN
ROV=RRT
PRCNT=1.
CCC NOT USED IN PAGE R7=R2
19 IF(RCNT.GT.9)GO TO 101
RJSZ=RJSZ-.06
RP=PRCNT
RCNT=RCNT+1
CALL JUSTFY(JPG-1,R,IR,KR,NP,RN,RSTFAC,-1.0,R4,R5,R6,R8,R9)
110 IF(ROV.LE.RRT+.01)RETURN
IF(RJSZ.GT.4)RJSZ=4
PRCNT=(ROV-RZRO)/(RRT-RZRO)
IF(PRCNT.NE.RP)GO TO 19
C GO BACK AND EXPAND SOME MORE
101 R4=RZRO
R5=ROV
R8=RZRO
R9=RRT-.001
C JUSTIFYING SPACE DIMINISHES EACH TIME AROUND.
CALL MOVIT(RN,KR,R4,R5,R8,R9)
C RVX SHOULD BE FARTHEST POINT TO RIGHT.
END
SUBROUTINE TURN(J,K,L,X)
C FINDS RESTS BEFORE AND AFTER BAR LINES FOR PAGE TURNS
COMMON /PX/KPN(1) /Q/Q(1)
DATA RMETER/4.0/
DO 1 M=J,K,L
R=CODEN(KPN,M,Q,N)
IF(R.EQ.1)RETURN
IF(R.EQ.4)RETURN
IF(R.NE.18)GO TO 3
C FINDS LAST METER GIVEN (4/4 IS DEFAULT)
IF(Q(N+5).LT.98)GO TO 4
RMETER=4
GO TO 1
4 RMETER=4.01/Q(N+6)*Q(N+5)
C 2ND PART OF COMPOSITE METERS ARE IGNORED.*******
GO TO 1
3 IF(R.NE.2)GO TO 1
IF(Q(N).LT.6)GO TO 2
C LOOK FOR NUMBERED RESTS AND REPEAT BARS (P8=-4, -5)
IF(Q(N+8).LE.-4)RETURN
C NOW WE HAVE A NUMBERED REST. MULT. NUMB. BY RHYTH. VALUE OF METER.
X=X+Q(N+8)*RMETER
GO TO 1
2 X=X+Q(N+7)
1 CONTINUE
END
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SUBROUTINE MNMX(IDIF,JRN)
C00017 ENDMK
C⊗;
SUBROUTINE MNMX(IDIF,JRN)
DIMENSION JRN(1)
COMMON /MNX/MIN,MAX,JT
L=MIN
N=MAX
CALL MINMAX(JRN)
J=MAX-MIN
IF(J.LE.IDIF)GO TO 1
MIN=L
MAX=N
RETURN
1 IDIF=J
END
SUBROUTINE FNDTRN(RPG,PGTRN,JBAR,IBAR,KT,KB)
DIMENSION PGTRN(1),JBAR(1),IBAR(1)
COMMON /JLINE/JLINE,SIZX /BRJ/JTOT,TURN,NB,DSK /KNUM/KNUM
TYPE 20
ACCEPT 21,TURN,JPP,P,KNUM
20 FORMAT(
1' TYPE TURN TIME UNIT, NUM OF PAGES, LNS PER PAGE, 1ST PG. NUM.'
1/)
21 FORMAT(F,I,F,I)
IF(P.EQ.0)P=10
IF(TURN.EQ.0)TURN=2
C DEFAULT = HALF REST FOR TURN AT FIRST
CC P=LPG/JP
LT=1
PGTRN(KT)=1000.
NTOT=JTOT
KB=0
MM=1
IF(KNUM.EQ.0)KNUM=1
IF(MOD(KNUM,2).EQ.0)MM=2
SPG=0
XT=TURN
7 RPG=NTOT/JLINE+.5
JP=RPG/(P*SIZX)+.5
C JP= HOW MANY PAGES
IF(JPP.GT.0)JP=JPP
IF(JP.LT.2)MM=1
C ONLY ONE PAGE IF NOT ENOUGH STUFF LEFT FOR TWO.
JPP=JPP-MM
RPG=JP*P
AV=(NTOT*MM)/RPG
IF(SPG.EQ.0)SPG=RPG
JAV=AV*P
NAV=JAV/2
C FOR MINIMUM LINES PER PAGE
11 J=0
DO 1 K=LT,KT
J=J+JBAR(K)
1 IF(J.GE.JAV)GO TO 2
C JUMP OUT WHEN JPAGE IS IDEALLY FULL
2 L=-1
C FOR FLIPFLOP
N=K
M=K
NN=J
JJ=J
3 IF(PGTRN(K).GE.TURN)GO TO 4
C JUMP IF TURN FOUND
IF(J.GE.NAV)GO TO 10
CHECK TO SEE IF TOO SMALL A PAGE
TURN=TURN-.5
CUT DOWN REST SIZE AND TRY AGAIN.
GO TO 11
10 L=L+1
C FLIPFLOP
IF(L.EQ.0)GO TO 5
C NEXT BACKS UP IF MM=2 BACK UP TWICE FOR EACH 1 FORWARD
IF(L.GE.MM)L=-1
N=N-1
NN=NN-JBAR(N)
J=NN
K=N
GO TO 3
5 M=M+1
C MOVES AHEAD TO FIND RESTS
JJ=JJ+JBAR(M)
J=JJ
K=M
GO TO 3
4 KB=KB+1
IBAR(KB)=K
KB=KB+1
IBAR(KB)=100*MM+P
MM=2
C FIRST PAGE IS A SINGLE, DOUBLES AFTERWARD
NTOT=NTOT-J
CUT DOWN TOTAL SIZE TO LOOK AT
IF(NTOT.LE.JLINE)GO TO 9
C 200 IS JLINE(IDEAL SIZE OF A LINE)
TYPE 12,TURN
TURN=XT
C RESET TURN UNIT FOR NEXT PAGE(S)
LT=K+1
GO TO 7
C JP IS NUM OF LINES/PAGE FOR NOW
9 KB=KB+1
12 FORMAT(' TURN TIME UNIT =',F4.2)
END
SUBROUTINE BRJUGL(JBAR,KT,NBAR,MBAR,JRN,PGTRN,JTRN)
COMMON /BRJ/JTOT,TRN,NB,DSK /MNX/MIN,MAX,JT /Q/Q(1)
COMMON /FIN/LBAR,METR,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
1,NO1,LPG,MPG,CLEF,SIG,NO2,SPG,MTR1,MTR2
DIMENSION JBAR(1),NBAR(1),MBAR(1),JRN(1),PGTRN(1),JTRN(1)
NT=JT
L=0
KTOT=JTOT
KAV=JTOT/JT
LMIN=-1
LMAX=10000
LJ=0
NJ=0
LMM=-1
LDIF=10000
NBAR(1)=1
J=1
3 M=1
JAV=KTOT/NT
K=JBAR(J)
1 J=J+1
IF(J.GT.KT)GO TO 2
N=JBAR(J)
IF(K+N/2.GE.JAV)GO TO 2
M=M+1
K=K+N
GO TO 1
2 L=L+1
KTOT=KTOT-K
NT=NT-1
JRN(L)=K
IF(L.GE.200)PAUSE' ****** NBAR OVERFLOW >200 ******'
NBAR(L+1)=J
IF(NT.GT.0)GO TO 3
5 MAX=0
MIN=10000
DO 7 L=1,JT
K=JRN(L)
IF(K.LE.MAX)GO TO 6
MAX=K
MX=L
6 IF(K.GE.MIN)GO TO 7
MIN=K
MN=L
7 CONTINUE
J=MAX-MIN
IF(MAX.GE.LMAX.AND.J.GE.LDIF)GO TO 9
IF(MIN.GT.LMIN)LMIN=MIN
IF(MAX.LT.LMAX)LMAX=MAX
IF(J.LT.LDIF)LDIF=J
CALL RLOOP(MBAR(2),NBAR(2),JT)
C SAVE NBAR INFO IN MBAR
IF(MX.LT.MN)GO TO 32
IF(MX.LE.1)GO TO 5
JJ=0
JM=-1
JK=1
23 K=NBAR(MX+JJ)-JJ
C NEXT RIPPLES THE BARS, FROM MAX TO MIN.
MM=JBAR(K)
JRN(MX)=JRN(MX)-MM
JMX=JM+MX
JRN(JMX)=JRN(JMX)+MM
NBAR(MX+JJ)=K+JK
MX=JMX
IF(JJ.NE.0)GO TO 223
IF(MX.GT.MN)GO TO 23
GO TO 5
223 IF(MX.LT.MN)GO TO 23
GO TO 5
32 JJ=1
JM=1
JK=0
GO TO 23
9 CALL GET(NBAR,JBAR,MBAR,JRN)
CC9 CALL GET
IDIF=10000
JJT=JT-1
104 CALL MNMX(IDIF,JRN)
108 DO 102 J=1,JJT
IF(JRN(J).LE.KAV)GO TO 102
C DON'T MAKE IT SMALLER IF IT'S ALREADY LESS THAN AVERAGE.
I=NBAR(J+1)-1
IF(I.EQ.NBAR(J))GO TO 102
C WE'RE DOWN TO ONE BAR
JJ=JRN(J)-JBAR(I)
C SUBTRACT LAST BAR OF THIS LINE, ADD IT ON NEXT.
IF(JJ.LT.MIN)GO TO 102
KK=JRN(J+1)+JBAR(I)
IF(KK.GT.MAX)GO TO 103
C LET'S SEE IF FURTHER SHUFFLING WILL IMPROVE IT.
CALL MINMAX(JRN)
105 JRN(J)=JJ
JRN(J+1)=KK
NBAR(J+1)=NBAR(J+1)-1
GO TO 104
103 IF(J.EQ.JJT)GO TO 102
NN=KK
DO 106 K=J+1,JJT
LL=NBAR(K+1)-1
C CHECK ON WHAT WILL HAPPEN TO NEXT LINE.
MM=NN-JBAR(LL)
IF(MM.LT.MIN.OR.MM.GT.MAX)GO TO 102
NN=JBAR(LL)+JRN(K+1)
106 IF(NN.LE.MAX)GO TO 105
102 CONTINUE
204 CALL MNMX(IDIF,JRN)
208 DO 202 J=JT,2,-1
IF(JRN(J).LE.KAV)GO TO 202
C DON'T MAKE IT SMALLER IF IT'S ALREADY LESS THAN AVERAGE.
I=NBAR(J)
IF(I-1.EQ.NBAR(J-1))GO TO 202
C WE'RE DOWN TO ONE BAR
JJ=JRN(J)-JBAR(I)
C SUBTRACT LAST BAR OF THIS LINE, ADD IT ON NEXT.
IF(JJ.LT.MIN)GO TO 202
KK=JRN(J-1)+JBAR(I)
IF(KK.GT.MAX)GO TO 203
C LET'S SEE IF FURTHER SHUFFLING WILL IMPROVE IT.
CALL MINMAX(JRN)
205 JRN(J)=JJ
JRN(J-1)=KK
NBAR(J)=NBAR(J)+1
GO TO 204
203 IF(J.EQ.2)GO TO 202
NN=KK
DO 206 K=J-1,2,-1
LL=NBAR(K)
C CHECK ON WHAT WILL HAPPEN TO NEXT LINE.
MM=NN-JBAR(LL)
IF(MM.LT.MIN.OR.MM.GT.MAX)GO TO 202
NN=JBAR(LL)+JRN(K-1)
206 IF(NN.LE.MAX)GO TO 205
202 CONTINUE
CALL MINMAX(JRN)
IDIF=MAX-MIN
CALL RLOOP(MBAR(2),NBAR(2),JT)
400 MX=MAX+5
JR=1
C JR = HOW MANY BARS TO RIPPLE
I=MAX-MIN
IF(I.GT.IDIF)GO TO 402
CALL RLOOP(MBAR(2),NBAR(2),JT)
IDIF=I
402 DO 401 J=1,JT
401 IF(JRN(J).EQ.MIN)GO TO 408
C TRY RIPPLE EACH WAY FROM SMALLEST VALUE
408 IF(J.EQ.JT)GO TO 508
C RIPPLE FORWARD FIRST
I=NBAR(J+1)
JJ=JRN(J)+JBAR(I)
IF(JJ.GT.MX)GO TO 508
C SMALLEST ISN'T TOO BIG, NOW CHECK UP THE LINE.
NN=JRN(J+1)-JBAR(I)
IF(NN.LT.MIN)GO TO 404
C IF WE GET HERE THERE HAS BEEN IMPROVEMENT
JRN(J)=JJ
JRN(J+1)=NN
NBAR(J+1)=I+1
415 CALL MINMAX(JRN)
C NOW GO BACK AND TRY AGAIN.
GO TO 400
405 JRN(J)=JJ
DO 422 IB=J+1,N
LB=NBAR(IB)
JB=JRN(IB)-JBAR(LB)
NBAR(IB)=LB+1
IF(JB.LT.MIN)GO TO 421
JRN(IB)=JB
GO TO 415
421 IBB=IB+1
LC=NBAR(IBB)
JB=JB+JBAR(LC)
IF(JB.GT.MIN)GO TO 422
C NOW ADD A SECOND BAR
JRN(IBB)=JRN(IBB)-JBAR(LC)
LC=LC+1
JB=JB+JBAR(LC)
NBAR(IBB)=LC
422 JRN(IB)=JB
NBAR(IBB)=LC+1
JRN(IBB)=JRN(IBB)-JBAR(LC)
GO TO 415
C NOW GO BACK AND TRY AGAIN.
404 IF(J.EQ.JJT)GO TO 508
DO 406 N=J+1,JJT
LL=NBAR(N+1)
MM=NN+JBAR(LL)
IF(MM.GT.MX)GO TO 508
IF(MM.GT.MIN)GO TO 409
C NEXT TO RIPPLE 2 BARS!
412 MN=MM+JBAR(LL+1)
C ADD ON A SECOND BAR
IF(MN.GT.MX)GO TO 508
C DON'T WORRY ABOUT IT BEING TOO SMALL (YET)
NN=JRN(N+1)-JBAR(LL)-JBAR(LL+1)
IF(NN.GT.MIN)GO TO 405
GO TO 406
409 NN=JRN(N+1)-JBAR(LL)
IF(NN.GE.MIN)GO TO 405
406 CONTINUE
C TRY RIPPLE EACH WAY FROM SMALLEST VALUE
508 IF(J.EQ.1)GO TO 502
IF(J.EQ.LJ.AND.MX-MN.EQ.LMM)GO TO 502
IF(JDIF.EQ.IDIF)GO TO 150
ICNT=0
GO TO 151
150 ICNT=ICNT+1
IF(ICNT.EQ.10)GO TO 515
151 JDIF=IDIF
C THIS SHOULD AVOID GETTING INTO A LOOP
LJ=J
LMM=MX-MN
C RIPPLE BACK NOW
I=NBAR(J)-1
JJ=JRN(J)+JBAR(I)
IF(JJ.GT.MX)GO TO 502
C SMALLEST ISN'T TOO BIG, NOW CHECK UP THE LINE.
NN=JRN(J-1)-JBAR(I)
IF(NN.LT.MIN)GO TO 504
C IF WE GET HERE THERE HAS BEEN IMPROVEMENT
JRN(J)=JJ
JRN(J-1)=NN
NBAR(J)=I
GO TO 415
505 JRN(J)=JJ
DO 522 IB=J-1,N,-1
LB=NBAR(IB+1)-1
JB=JRN(IB)-JBAR(LB)
NBAR(IB+1)=LB
IF(JB.LT.MIN)GO TO 521
JRN(IB)=JB
GO TO 415
521 IBB=IB-1
LC=NBAR(IB)-1
JB=JB+JBAR(LC)
IF(JB.GT.MIN)GO TO 522
JB=JB+JBAR(LC-1)
NBAR(IB)=LC
JRN(IBB)=JRN(IBB)-JBAR(LC)
CHECK THIS OUT!!
LC=LC-1
522 JRN(IB)=JB
JRN(IBB)=JRN(IBB)-JBAR(LC)
NBAR(IB)=LC
GO TO 415
504 IF(J.LE.2)GO TO 502
DO 506 N=J-1,2,-1
LL=NBAR(N)-1
MM=NN+JBAR(LL)
IF(MM.GT.MX)GO TO 502
IF(MM.GT.MIN)GO TO 509
512 MN=MM+JBAR(LL-1)
IF(MN.GT.MX)GO TO 502
NN=JRN(N-1)-JBAR(LL)-JBAR(LL-1)
IF(NN.GT.MIN)GO TO 505
GO TO 506
509 NN=JRN(N-1)-JBAR(LL)
IF(NN.GE.MIN)GO TO 505
506 CONTINUE
502 IF(J.EQ.NJ.AND.MX-MN.EQ.LMM)GO TO 515
C CHECK TO AVOID ENDLESS LOOP.
NJ=J
IF(J.EQ.JT)GO TO 515
C LOOK FOR OTHER LINES = MIN.
DO 510 K=J+1,JT
IF(JRN(K).NE.MIN)GO TO 510
J=K
GO TO 408
510 CONTINUE
515 CALL GET(NBAR,JBAR,MBAR,JRN)
CC515 CALL GET
13 DO 14 L=2,JT
K=NBAR(L)
MM=JRN(L)
KK=JRN(L-1)
IF(MM.GE.KK)GO TO 12
C JUGGLES ADJACENT LINES
N=JBAR(K-1)
IF(KK-MM.LT.N)GO TO 14
JRN(L-1)=KK-N
JRN(L)=MM+N
NBAR(L)=K-1
GO TO 13
12 N=JBAR(K)
IF(MM-KK.LE.N)GO TO 14
JRN(L-1)=KK+N
JRN(L)=MM-N
NBAR(L)=K+1
GO TO 13
14 CONTINUE
46 J=1
NBAR(JT+1)=KT+1
JAV=JTOT/JT
CALL MINMAX(JRN)
308 FORMAT(' AVG=',I3,' MIN=',I3,' MAX=',I3)
TYPE 308,JAV,MIN,MAX
IF(DSK)WRITE(21,308)JAV,MIN,MAX
307 DO 310 K=1,KT
L=JBAR(K)
IF(PGTRN(K).GE.TRN)L=-L
310 JTRN(K)=L
C ABOVE MAKES NEG. BAR VALUES WHERE TURNS ARE POSSIBLE.
LJ=0
306 FORMAT(I5,' (BAR',I3,')',3X50I5)
309 DO 305 K=1,JT
LJ=LJ+1
NBAR(K)=NBAR(K+1)-NBAR(K)
C NBAR NOW HAS NUM. OF BARS PER LINE.
L=NBAR(K)-1+J
MM=NB+J-1
TYPE 306,JRN(K),MM,(JTRN(N),N=J,L)
IF(DSK)WRITE(21,306)JRN(K),MM,(JTRN(N),N=J,L)
IF(LJ.LT.MPG)GO TO 305
LJ=0
IF(DSK)WRITE(21,3066)
TYPE 3066
3066 FORMAT(' ************')
305 J=L+1
NBAR(JT+1)=0
NBAR(JT+2)=0
END
SUBROUTINE GET(NBAR,JBAR,MBAR,JRN)
COMMON /MNX/MIN,MAX,JT
DIMENSION MBAR(1),JBAR(1),JRN(1),NBAR(1)
J=1
DO 1 K=2,JT+1
NBAR(K)=MBAR(K)
N=0
DO 2 L=J,MBAR(K)-1
C FIX UP JRN ARRAY
2 N=N+JBAR(L)
JRN(K-1)=N
1 J=MBAR(K)
END
CC SUBROUTINE MNMX(IDIF,JRN)
CC COMMON /MNX/MIN,MAX,JT /XRN/JRN(1)
CC L=MIN
CC N=MAX
CC CALL MINMAX(JRN)
CC J=MAX-MIN
CC IF(J.LE.IDIF)GO TO 1
CC MIN=L
CC MAX=N
CC RETURN
CC1 IDIF=J
CC END
***** Arrow at Line 12 of 543 ***** Page 2 of 2 ***** 18R +366C *****
C*************** SUBROUTINE JUSTFY, FUNCTION OTHSID *************
SUBROUTINE JUSTFY(JLP,R,IR,NO,NP,RN,RSTFAC,R2,R4,R5,R6,R8,R9)
CC IMPLICIT INTEGER(A-Q,S-Z)
CC REAL EXTEN,PRCNT,ACCX,SPFAC
COMMON /JSTFY/ROV,PRCNT,RJSZ/KJY/ KY,JY
CC COMMON /STF/RSTFAC(0/7),RSTJ2 /JSTFY/ROV,PRCNT,RJSZ/KJY/ KY,JY
DIMENSION IR(2,250),R(2,250),RN(1),NO(1),NP(1),RSTFAC(0/1)
DATA RBX/6.0/,RBZ/8.0/,SPFAC/0.20/
CC DATA RSP/.5/,RI/4.5/
CC RSP=.5
CCC SPFAC=.5
DO 11 KN=0,JLP
RSPC=0
R8=KN
N=0
DO 2 K=1,KY
L=NP(K)
RL=RN(L)
C RL=WDCNT-2
RA=RN(L+1)
C RA=CODE NUM.
RB=RN(L+3)
C RB=POSITION(P3)
IF(RN(L+2).EQ.R8)GO TO 77
C THIS STAFF?
IF(RA.NE.4)GO TO 2
C SKIPS HOMED NOTES (IN CHORDS)
77 IF(RA.LT.3)GO TO 20
IF(RA.EQ.4)GO TO 444
IF(RA.EQ.3)GO TO 333
C LOOKS AT NOTES,RESTS,CLEFS,BAR LINES,KSIGS,METERS.
IF(RA.LT.17)GO TO 2
GO TO 10
333 IF(RL.LT.3)GO TO 10
C <3 MEANS NOTHING IN P5
IF(RN(L+5).GT.4)GO TO 2
C NOT A REAL CLEF IF >4 (0=TREB, 1=BASS, 2=ALT, 3=TEN, 4=PERC.)
GO TO 10
444 IF(RL.GT.3)GO TO 2
CC FOR REPEAT BAR WDCNT IS 3 -- 10/77 444 IF(RL.GT.2)GO TO 2
C SHOULD CHECK ON BAR LINES NO MATTER WHICH STAFF
GO TO 10
20 IF(RA.NE.2)GO TO 113
C ASSUMES WD CNT. IS GREAT ENOUGH!?!?!?!?
IF(RN(L+6))GO TO 2
IF(RN(L+7))GO TO 2
C SKIP INVIS. RESTS AND RESTS WITH NEG. RHYTH. (PUT THIS IN OTHER JUST. PROGS.)
GO TO 10
113 IF(RL.LT.7)GO TO 10
C NOW NOTES. SKIP IF NEG. VALUE IN P9 (IT'S A SUPPLEMENTAL NOTE.)
IF(RN(L+9).LT.0)GO TO 2
10 N=N+1
R(1,N)=RB
IR(2,N)=L
IF(N.EQ.250)GO TO 28
C ONLY TREATS 250 ITEMS AT A TIME.
2 CONTINUE
IF(N.EQ.0)GO TO 11
28 DO 23 K=1,N
23 IF(RN(IR(2,K)+1).NE.4)GO TO 24
C SKIPS IF ONLY BAR LINES ON THIS STAFF
GO TO 11
24 RSZ=RSTFAC(KN)*PRCNT
CALL SORT2(R,N)
C JUMP IF LAST IS A BAR LINE.
K=0
JLDGR=0
JX=0
22 K=K+1
122 L=IR(2,K)
RA=RN(L+1)
C RA IS NOW CODE NUM.
RL=RN(L)
C RL=WDCNT-2
RB=0
RD=0
C RD WILL HOLD SPACE TO ADD TO PREV. ITEM, IF NEEDED.
RX=RN(L+5)
C RX=PARAM 5
RX6=RN(L+6)
RY=1
RW=AMOD(RN(L+4),100.)
RSP=SPFAC*RSTFAC(IFIX(RN(L+2)))
IF(RA.GT.1)GO TO 4
RZ=RN(L+7)
IF(LDGR.NE.JLDGR)JLDGR=0
C CHECK FOR PRESENCE OF LEDGER LINES WITH SUCCESSIVE NOTES
LDGR=0
JK=K
DO 32 JJ=JK+1,N+1
K=JJ
RB=R(1,JJ)-R(1,JJ-1)
IF(RB.GT.0.1)GO TO 320
C PUTS THEM AT EXACT SAME POINT IF CLOSER THAN .1
R(1,JJ)=R(1,JJ-1)
GO TO 32
320 IF(RB.GT.RSP)GO TO 35
32 CONTINUE
C FOUND HOW MANY MEMBERS TO CHORD.
35 RB=0
K=K-1
RQ=0
125 RC=ABS(RN(L+4))
IF(RC.LT.60)GO TO 637
IF(RC.LT.180)RY=.6
C FOUND A MINI-NOTE
637 RSDF=0
IF(RA.EQ.1)GO TO 437
C JUMP IF NOTE
RDF=-1
C NOW IT'S ANYTHING BUT A NOTE
GO TO 137
437 IF(RL.LT.8)GO TO 237
C JUMP IF THERE IS NOT P10 TO LOOK AT
RW=RN(L+10)
C PUT P10 INTO RW
GO TO 337
237 RW=0
337 IF(RDF.LT.0)GO TO 537
C JUMP IF PREVIOUS WAS NOT A NOTE
IF(RW.EQ.RDF)GO TO 137
C SKIP TO FAR END OF LOOP IF THINGS ARE ON DIFF. STAVES. (CLEFS?, ETC?)
RSDF=-1
537 RDF=RW
C SAVE STAFF INFO FOR NEXT TIME AROUND.
137 DO 37 JJ=JK,K
C******* IF(RD.NE.0)GO TO 38
C FINDS ONLY HIGH OR! LOW LED. LINE.
JR=IR(2,JJ)
RW=AMOD(RN(JR+4),100.)
IF(RW.GT.12)GO TO 277
IF(RW.GE.2)GO TO 38
277 LDGR=-1
IF(RW.GT.11)LDGR=1
IF(JLDGR.EQ.LDGR)GO TO 36
JLDGR=LDGR
C LDGR IS FOR LEDGER LINES.
GO TO 38
36 IF(RD.GE.1.5)GO TO 38
RD=1.5
RQ=RD
38 IF(RB.GT.2)GO TO 222
C JUMP IF LARGE SPACE AFTER NOTE IS ALREADY SET UP.
RZZ=RN(JR+7)
RE=RN(JR+5)
IF(RB.GE.2)GO TO 477
RC=1.5
IF(RZZ.LT.10)GO TO 378
IF(RZZ.GE.20)RC=3.
C 10=DOT, 20=DOUBLE DOT
GO TO 377
378 IF(RE.GE.20)GO TO 477
IF(AMOD(RZZ,10.).EQ.0)GO TO 477
377 RB=RC+EXTEN(RZZ)
C SPACE FOR DOT OR TAIL(IF STEM UP)
477 IF(ABS(RN(JR+6)).EQ.10)RB=RB+2
C FOR CHORD TONES ON RIGHT OF STEM UP.
C LOOKS THROUGH ALL NOTES OF A CHORD.
222 RC=AMOD(RE,10.0)
IF(RC.EQ.0)GO TO 37
C JUMP IF NO ACCIS. NOW SEE IF THERE'S SPACE FOR ACCI.
IF(RN(JIR+1).NE.1)GO TO 425
C* RX=0
C* IF(RN(JR).GE.8)RX=RN(JR+10)
C* RXX=0
C* IF(RN(JIR).GE.8)RXX=RN(JIR+10)
C* RDF=0
C* IF(RX.NE.RXX)RDF=100.
C SAVE INFO ON NOTES ON DIFF. STAVES.
C* IF(RXX.EQ.1.OR.RX.EQ.2)RDF=-RDF
C**** THIS NEXT AREA PROBABLY NEEDS MORE WORK (2/78) ***********
C JIR IS POINTER TO PREVIOUS ITEM. SKIP IF NOT A NOTE.
KX=RC
C KX=ACCI ON CURRENT NOTE
RD=1
C ADD A LITTLE SPACE FOR ACCI. ANYHOW.
RX=RN(L+4)
RXX=ABS(RX)
C THIS NOTE
577 IF(RXX.LT.80)GO TO 677
C FIND MINIS, HARMONICS, ETC.
RXX=RXX-100
GO TO 577
677 IF(RX)RXX=-RXX
RX=RXX
RDIF=RN(JIR+4)
RXX=ABS(RDIF)
777 IF(RXX.LT.80)GO TO 877
C FIND MINIS, HARMONICS, ETC.
RXX=RXX-100
GO TO 777
877 IF(RDIF)RXX=-RXX
RDIF=RX-RXX
C HEIGHT DIFF. JUMP OUT IF TOO CLOSE TOGETHER. AMOD IS FOR GRACE NOTES, ETC.
RX=3
JSTM=RN(JIR+5)/10.0
C JSTM=STEM DIRECTION OF PREVIOUS NOTE. 1=UP, 2=DOWN
IF(RDIF.GT.0)GO TO 427
C JUMP IF PREV NOTE IS BELOW. LIMITS: b OR NAT.=3, #=4
IF(JSTM.NE.2)GO TO 424
IF(AMOD(RN(JIR+7),10.0).GE.1)GO TO 425
C JUMP IF PREV. NOTE HAS STEM DOWN WITH TAIL. THEN WE NEED SPACE.
424 IF(KX.NE.2)RX=5
GO TO 428
427 IF(KX.EQ.2)RX=4
C PREV NOTE IS ABOVE. LIMITS: b OR NAT.=5, #=3
428 IF(ABS(RDIF).LT.RX)GO TO 425
IF(RDIF)GO TO 426
C JUMP IF THIS NOTE IS LOWER THAN PREV.
IF(JSTM.NE.1)GO TO 426
C NO BIG SPACE NEEDED IF PREV. NOTE HAS STEM DOWN AND IS BELOW.
425 RW=2.8
IF(IFIX(AMOD(RE,10.0)).EQ.4)RW=4.8
CATCHES DOUBLE FLAT (=4)
RD=RW*RY+EXTEN(RE)+OTHSID(RN,JR)
CGHB USE 2.8 FOR SIZE OF ACCIS (THEY'RE REALLY 3)425 RD=2*RY+EXTEN(RE)
426 IF(RQ.GT.RD)RD=RQ
RQ=RD
C FUNCT. EXTEN=AMOD(X,1.)*10.
37 CONTINUE
IF(RY.NE.1)RB=RB-.5*RJSZ
C MINI NOTES NEED LESS SPACE
250 IF(RSDF)GO TO 17
ACCX=0
CC RC=0
JIR=JX+2
IF(JIR.GE.N)GO TO 25
RW=R(1,JIR-1)
DO 132 JJ=JIR,N
IF(RW.NE.R(1,JJ))GO TO 25
KX=IR(2,JJ)
C GET POINTER
IF(RN(KX+1).NE.1)GO TO 25
C ONLY CHECK ON NOTES (THIS IS FOR CHRD NOTES WITH ACCIS)
CC RE=ABS(RN(KX+6))
CC IF(RE.GE.10)RC=-2.6
CC IF(RE.EQ.20)RC=-RC
RC=OTHSID(RN,KX)
RE=AMOD(RN(KX+5),10.0)
C FIND AN ACCI
IF(RE.GE.1)RC=RC+2
IF(IFIX(RE).EQ.4)RC=RC+2
C FOUND AN ACCI RE=4=DOUBLE FLAT
RC=AMOD(RE,1.0)*10.0+RC
C ADD ANY EXTENSION TO THE LEFT
IF(RC.GT.ACCX)ACCX=RC
CC RC=0
IF(ACCX.GT.RD)RD=ACCX
132 CONTINUE
GO TO 25
4 IF(RA.NE.2)GO TO 33
C NEXT FOR DOTTED RESTS - IN P6
IF(RL.GE.4)RB=RN(L+6)*1.5
C NOW GO BACK TO SEE IF THERE IS A NOTE IN SAME HORIZ. POS.
GO TO 250
33 IF(RA.NE.3)GO TO 29
RB=3
IF(RN(L+4).GT.80)RB=1.5
C CHECK ON SIZE NEEDED FOR CLEFS. >80 = MINICLEF
29 IF(RA.NE.4)GO TO 26
C BAR LINES
RB=-RJSZ/2
RD=.9
KX=RN(L+4)/1000.
IF(KX.LE.0.)GO TO 25
RD=RD+1.2
C ADD A LITTLE SPACE IN FRONT OF DBL BAR.
IF(RL.LT.3)GO TO 25
IF(KX.EQ.1.OR.KX.EQ.3)RD=RD+RD
C REPT BAR WITH DOTS TO LEFT. ADD SPACE IN FRONT OF IT.
RB=-RB/RBX
129 IF(KX.GE.2)RB=RBZ*RB
C IF DOTS TO RIGHT ADD MORE SPACE AFTER REPT BAR.
GO TO 25
26 IF(RA.NE.18)GO TO 30
C METER
RC=0
IF(RL.GE.7)RC=9
C FOR COMPOSITE METERS. NO CHECK FOR DBL DIGITS YET.
RB=-1
RD=1
IF(RX6.LE.9.AND.RX.LE.9)GO TO 31
C CHECKS FOR 2-DIGIT METERS
RD=2
RB=0
31 RB=RB+RC
GO TO 25
30 IF(RA.NE.17)GO TO 17
C KSIG
RX=ABS(RX)
IF(RX.GE.100)RX=RX-100
C +100 FOR NATURALS AS KEYSIG.
RB=2*(RX-1)-2
C SPACES FOR CORRECT NUM OF ACCIS. RX=NUM OF ACCIS.
RD=2
25 IF(JX.GT.0)R(2,JX)=R(2,JX)+RD*RSZ
17 RC=(RB+RJSZ)*RSZ
C RJSZ=DEFAULT SIZE
JIR=L
C SAVE THE POINTER FOR ACCI. CHECK AT 110
JX=K
R(2,JX)=RC
3 IF(K.LT.N)GO TO 22
RA=R(1,1)
RB=R(2,1)
DO 13 KX=2,JX
RE=R(1,KX)
C POS. BEFORE SHIFTING
IF(ABS(RE-RA).GT.RSP)GO TO 14
CCC IF(ABS(RE-RA).GT..5)GO TO 14
IF(R(2,KX).GT.RB)GO TO 16
C SKIPS DOUBLE STOPS AND VERY CLOSE ITEMS
GO TO 13
C JUMP WHEN SPACE TO ADD IS SMALLER THAN WHAT'S ALREADY THERE
14 RD=RA+RB-RE
IF(RD.LE.0)GO TO 16
C THERE'S ENOUGH ROOM
ROV=ROV+RD
140 R4=RE+RSPC-.001
R5=10000
R8=RD
R9=0
C GO EXPAND IT
IF(R(2,KX).EQ.0)GO TO 15
CALL MOVIT(RN,NO,R4,R5,R8,R9)
C???? IF(R2.LE.4)GO TO 15
C SKIP NEXT IF COMING FROM 'PAGE' OR 'JUST'
IF(R2.LE.7)GO TO 15
R5=R4
R4=RA+.001+RSPC
R8=R4
R9=R5+RD-.001
C FOR ITEMS ON OTHER LINES.
CALL MOVIT(RN,NO,R4,R5,R8,R9)
15 RSPC=RSPC+RD
C RSPC SAVES TOTAL SPACE ADDED
16 RB=R(2,KX)
13 RA=RE
11 CONTINUE
END
FUNCTION OTHSID(RN,J)
DIMENSION RN(1)
OTHSID=0
A=ABS(RN(J+6))
IF(A.GE.10)OTHSID=-2.6
C OTHSID=SPACE NEEDED (+ OR -) BECAUSE OF NOTE ON 'WRONG' SIDE OF STEM.
IF(A.GE.20)OTHSID=-OTHSID
END